(defpackage :rollover-input
  (:use :cl)
  (:nicknames :ri)
  (:export :rollover-input-mixin
           :leave-input-timeout
           :*default-keypad-timeout*
           :popup-keypad
           :keypad-input
           :close-keypad))

(in-package :rollover-input)

(defvar *default-keypad-timeout* 0.25)

(defclass rollover-input-mixin (bt:basic-trial)
  ((leave-input-timeout :initform *default-keypad-timeout* :accessor leave-input-timeout)))

(defun handle-mouse-motion (trial motion)
  (let ((leave (when (getf motion :leave)
                 (d:find-id-or-die (d:root (p:diagram trial)) (getf motion :leave))))
        (enter  (when (getf motion :enter)
                  (d:find-id-or-die (d:root (p:diagram trial)) (getf motion :enter)))))
    (when (and leave
               (typep leave 'd:input-argument)
               (or (not (bt:input trial))
                   (eq leave (kp:target (bt:input trial)))))
      (when (if (bt:input trial)
                (start-input-timer trial (bt:input trial))
                (leave-argument trial leave))
        (return-from handle-mouse-motion nil)))
    (when (and enter
               (typep enter 'd:input-argument))
      (cond
        ((and (bt:input trial)
              (eq enter (kp:target (bt:input trial))))
         (kp:cancel-timer (bt:input trial)))
        ((or (not (bt:input trial))
             (not (eq enter (kp:target (bt:input trial)))))
         (when (bt:input trial)
           (when (cleanup-input trial (bt:input trial))
             (return-from handle-mouse-motion nil)))
         (exp:lg 'enter :node (d:id enter))
         (setf (d:highlighted enter) t
               (bt:input trial) (bt:read-input trial enter)))))
    (when (or enter
              leave)
      (setf (gwee:view-needs-update-p (p:diagram trial)) t))
    t))

(exp:define-action popup-keypad ((trial rollover-input-mixin)
                                 (e:mouse-motion :var motion)
                                 (bt:fill-mode))
  (handle-mouse-motion trial motion))

(defun concat-quantity (node str)
  (setf (d:quantity node) (concatenate 'string (d:quantity node) str)))

(defun del-quantity (node)
  (when (d:quantity node)
    (setf (d:quantity node) (subseq (d:quantity node)
                                    0
                                    (max 0 (1- (length (d:quantity node))))))
    (when (zerop (length (d:quantity node)))
      (setf (d:quantity node) nil))))

(defmethod bt:place-input-view ((trial rollover-input-mixin) (input kp:tiny-keypad) target)
  "A special hack for the tiny-keypad. Since it has an invisible
border, we need to handle its height differently."
  (gwee:sync-views trial)
  (setf (gwee:view-y input)
        (ecase (d:input-location target)
          (:above
           (- (geom:y target)
              (gwee:view-height input)
              (- (gwee:margin-bottom (slot-value input 'kp::default)))))
          (:below
           (- (geom:bottom target) 0 (gwee:margin-top (slot-value input 'kp::default)))))
        (gwee:view-x input)
        (- (geom:x target) (truncate (- (gwee:view-width input) (geom:width target)) 2)))
  (bt:fit-input-view trial input target))

(defmethod bt:fit-input-view ((trial rollover-input-mixin) (input kp:tiny-keypad) target)
  (let* ((inner (slot-value input 'kp::default))
         (bottom (> (+ (- (gwee:view-y input) (gwee:view-scroll-y (gwee:view-parent input)))
                       (gwee:view-height input))
                    (gwee:view-height (gwee:view-parent input))))
         (top (< (+ (gwee:view-y input)
                    (gwee:margin-top inner))
                 (gwee:view-scroll-y (gwee:view-parent input)))))
    (cond
      (bottom
       (setf (gwee:view-y input) (+ (- (geom:y target)
                                       (gwee:view-height input))
                                    (gwee:margin-bottom inner))))
      (top
       (setf (gwee:view-y input) (- (geom:bottom target) (gwee:margin-top inner)))))))

(defun leave-input (trial kp x y state)
  (declare (ignore state))
  (setf x (+ (- x (gwee:view-cache-top-x (p:diagram trial)))
             (gwee:view-scroll-x trial))
        y (+ (- y (gwee:view-cache-top-y (p:diagram trial)))
             (gwee:view-scroll-y trial)))
  (let ((enter (d:find-if-on-tree (lambda (n)
                                    (and (typep n 'd:input-argument)
                                         (geom:insidep n x y)))
                                  (d:root (p:diagram trial))
                                  :from-end t)))
    (cond
      ((geom:insidep (kp:target kp) x y)
       ;; do nothing
       )
      ;; fake an enter event because the existing method in events.lisp
      ;; uses xrel,yrel to find the old node which could be the same as
      ;; the new one if the movement was small enough and ignore
      ;; it. Ignoring it would be wrong because the input dialog was
      ;; occluding the node until now so the "old" node would be
      ;; incorrectly determined.
      (enter
       (cleanup-input trial kp)
       (exp:state-dispatch-event exp:*experiment* trial (make-instance 'e:motion-event :enter enter :leave nil)))
      (t
       (start-input-timer trial kp)))))

(defun start-input-timer (trial kp)
  (kp:cancel-timer kp)
  (setf (kp:timer kp)
        (exp:start-timer (leave-input-timeout trial) :tag :keypad)))

(defun leave-argument (trial arg)
  (exp:lg 'leave :node (d:id arg))
  (setf (d:highlighted arg) nil
        (gwee:view-needs-update-p (p:diagram trial)) t)
  (p:finish-input-box trial arg))

(exp:define-action close-keypad ((trial rollover-input-mixin)
                                 (exp:timeout :tag :keypad)
                                 (bt:fill-mode))
  (cleanup-input trial (bt:input trial)))

(defun cleanup-input (trial kp)
  "Returns NIL if we're still in fill mode. non-NIL otherwise."
  (kp:cancel-timer kp)
  (bt:delete-input trial)
  (leave-argument trial (kp:target kp)))

(defun enter-input (kp)
  (declare (ignore state))
  (kp:cancel-timer kp))

(defmethod bt:read-input ((trial rollover-input-mixin) target)
  (let ((i (kp:read-string (p:diagram trial)
                           (geom:x target)
                           (geom:y target)
                           :target target
                           :class 'kp:tiny-keypad)))
    (exp:lg 'show-input-dialog :node (d:id target))
    (gwee:add-hook (gwee:leave-hook i) (lambda (v x y s) (leave-input trial v x y s)))
    (gwee:add-hook (gwee:enter-hook i) (lambda (v x y s) (declare (ignore x y s)) (enter-input v)))
    (bt:place-input-view trial i target)
    (bt:keypad-opened trial target)
    i))

;; (exp:define-action rollover-input ((state rollover-input-mixin)
;;                                    (kp:keypad-input)
;;                                    (bt:fill-mode))
;;   (let ((hl (d:find-if-on-tree 'd:highlighted (d:root (p:diagram state)))))
;;     ;;; XXX: this doesn't always work it seems! I got a crash while
;;     ;;; quickly going through a problem!
;;     (when hl
;;       (cond
;;         ((char= kp:keypad-input #\Backspace)
;;          (exp:lg 'input :source :kbd :value :backspace :node (d:id hl))
;;          (del-quantity hl)
;;          (bt:refresh-diagram state (p:diagram state)))
;;         ((find kp:keypad-input "0123456789+-*/ ")
;;          (exp:lg 'input :source :kbd :value (string kp:keypad-input) :node (d:id hl))
;;          (concat-quantity hl (string kp:keypad-input))
;;          (bt:refresh-diagram state (p:diagram state)))
;;         (t
;;          (exp:lg 'keypress :char kp:keypad-input))))))

(exp:define-action keypad-input ((trial rollover-input-mixin)
                                 (kp:keypad-input :var input-string :key :value)
                                 (bt:keypad-target :var target-id :key :id)
                                 (bt:fill-mode))
  (let ((target (d:find-id-or-die (d:root (p:diagram trial)) target-id)))
    (check-type target d:input-argument)
    (case input-string
      (:backspace
       (exp:lg 'input :source :click :value :backspace :node (d:id target))
       (when (d:quantity target)
         (setf (d:quantity target) (string-right-trim " " (d:quantity target)))
         (when (plusp (length (d:quantity target)))
           (setf (d:quantity target) (subseq (d:quantity target) 0 (1- (length (d:quantity target))))
                 (d:quantity target) (string-right-trim " " (d:quantity target)))
           ;; XXX: sdl borks with empty strings. dunno why.
           (when (string= (d:quantity target) "")
             (setf (d:quantity target) nil))
           (bt:refresh-diagram trial (p:diagram trial)))))
      (t
       (exp:lg 'input :source :click :value input-string :node (d:id target))
       (setf (d:quantity target) (concatenate 'string (d:quantity target) input-string))
       (bt:refresh-diagram trial (p:diagram trial))))))

(exp:define-action toggle-keypad ((trial rollover-input-mixin)
                                  (e:click-node :var id))
  (let ((node (d:find-id-or-die (d:root (p:diagram trial)) id)))
    (if (and (typep node 'd:input-argument)
             (or (not (bt:input trial))
                 (eq (kp:target (bt:input trial)) node)))
        (if (bt:input trial)
            (progn
              (kp:cancel-timer (bt:input trial))
              (bt:delete-input trial))
            (progn
              (setf (d:highlighted node) t
                    (bt:input trial) (bt:read-input trial node))
              (bt:refresh-diagram trial (p:diagram trial))))
        (exp:lg 'click-node :node (d:id node)))))
